home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / tweek-it.lisp < prev   
Encoding:
Text File  |  1993-02-26  |  12.1 KB  |  278 lines  |  [TEXT/CCL2]
  1. ;; file tweek-it.lisp
  2. ;; a WDEF Written in Lisp!
  3. ;; Copyright (C) 1993 by John Montbriand. All Rights Reserved.
  4. ;; You may freely re-distribute/use this file, or portions
  5. ;; of this file (viz. the tweek-it routine), but, if you do,
  6. ;; please keep this notice with whatever you re-distribute.
  7. ;;          Thanx,  john
  8. ;;
  9. ;; Use this at your own risk: since I'm giving you the right
  10. ;; to use my code, in exchange, by using it, you agree to take
  11. ;; responsibility for any problems you may have because of it...
  12.  
  13. (require 'resources)
  14. (require 'quickdraw)
  15.  
  16. ;; tweek-it
  17. ;;   ...sets up a tweeked resource that points to your user procedure
  18. ;; for the specified type of definition procedure (MDEF, WDEF, LDEF...)
  19. ;; user-proc is a pointer to your Lisp routine which should have the correct
  20. ;; stack setup for the definition procedure being implemented.
  21. ;; tweek-it simply sets a pointer in the resource to point to 
  22. ;; your Lisp defined defproc.
  23. ;;   The resource is formatted as a jmp abs.l 68000 instruction:
  24. ;;                 "4EF9 0000 0000"
  25. ;; tweek-it sets the second and third words (the jump address) to
  26. ;; point to your Lisp procedure (which must be a defpascal function)
  27. ;; so when your WDEF/LDEF/anythingDEF gets called all the resource
  28. ;; does is bounce the PC to your Lisp routine.
  29. ;;
  30. ;; IMPORTANT:  If the requested resource doesn't exist, a new one is
  31. ;; added to the current resource file--this might cause some virus
  32. ;; protection schemes to become active.
  33. ;;
  34. ;; WARNING: MCL _MUST_ be the current resource file when you make
  35. ;; this call.
  36. ;;
  37. ;; Added call to ccl::make-wdef-handle, #_MoveHHI, and #_HLock
  38. ;; as recommended by Bill St. Clair Fri, 12 Feb 93 so WDEF's don't
  39. ;; crash while the MCL is in the background, or garbage collecting.
  40.  
  41. (defun tweek-it (type id user-proc)
  42.   (cond
  43.    ((equal type "WDEF")
  44.     (prog ((the-rsrc (get-resource type id t))
  45.            (lisp-style-wdef (ccl::make-wdef-handle user-proc)))
  46.       (#_MoveHHI lisp-style-wdef)
  47.       (#_HLock lisp-style-wdef)
  48.       (format t "~&creating a WDEF~%")
  49.       (if (macptrp the-rsrc)
  50.         (%hput-long the-rsrc (%ptr-to-int (%get-ptr lisp-style-wdef)) 2)
  51.         (let ((tweek (#_NewHandle 6)))
  52.           (%hput-word tweek #x4EF9 0)
  53.           (%hput-long tweek (%ptr-to-int (%get-ptr lisp-style-wdef)) 2)
  54.           (add-resource tweek type id :name "tweeked resource")))))
  55.    (t (prog ((the-rsrc (get-resource type id t)))
  56.       (if (macptrp the-rsrc)
  57.         (%hput-long the-rsrc (%ptr-to-int the-rsrc) 2)
  58.         (let ((tweek (#_NewHandle 6)))
  59.           (%hput-word tweek #x4EF9 0)
  60.           (%hput-long tweek (%ptr-to-int the-rsrc) 2)
  61.           (add-resource tweek type id :name "tweeked resource")))))))
  62.  
  63. ;; preserve-current-port ensures 
  64. (defmacro preserve-current-port ((gp) &body body)
  65.   "executes body preserving the current port"
  66.   `(rlet ((,gp :GrafPtr))
  67.      (#_GetPort current-port)
  68.      (let ((result (progn ,@body)))
  69.        (#_SetPort (%get-ptr ,gp))
  70.        result)))
  71.  
  72.  
  73. ; lisp-window-definition:  a window definition written entirly in Lisp.
  74. ; it's a smaller version of a window with the
  75. ; features:
  76. ;   - title in 9 point geneva font, left justified.
  77. ;   - the drag region is on all sides instead of just the title bar.
  78. ;   - the grow icon is in the struct region, not the content region.
  79. ; resource: WDEF=4
  80. ; procid:   (* 4 16) = 64 (multiply the resource id by 16)
  81. ; variations (add on to the procid when creating a window)
  82. ;   0 -- window with a grow box (procid = 64)
  83. ;   1 -- has no grow box (procid = 65)
  84. ; for more information about WDEFs, see the section on
  85. ; "defining your own windows" in inside macintosh,
  86. ; and see technical note 290.
  87. (defconstant kMyWDEFid 4 "resource id for our WDEF")    ; define the ID
  88.  
  89. (defpascal lisp-window-definition (:word varCode :ptr theWindow :word message
  90.                            :long param :long)
  91.   "A custom window definition in lisp!"
  92.   (preserve-current-port (current-port)
  93.     (rlet ((window-manager-port :GrafPtr)
  94.            (content :rect)       ; our content rectangle--window's portRect
  95.            (structure :rect)     ; structure rect--contains the content rect
  96.            (grow :rect)          ; grow box coordinates
  97.            (go-away :rect))      ; go-away box coordinates
  98.       (#_getwmgrport window-manager-port)       ; wmgr port is where we draw
  99.       (with-port theWindow
  100.         ;; everything's in global coordinates in the window-manager-port
  101.         ;; so we calculate all our part locations in global coordinates.
  102.         (copy-record (pref theWindow windowrecord.port.portrect) :rect content)
  103.         (#_LocalToGlobal content)       ; topLeft
  104.         (#_LocalToGlobal (%inc-ptr content 4))          ; botRight
  105.         (copy-record content :rect structure)
  106.         (inset-rect structure -5 -5)
  107.         (setf (rref structure rect.top) (- (rref structure rect.top) 8))
  108.         (copy-record structure :rect grow)
  109.         (setf (rref grow rect.topLeft) (rref content rect.botRight))
  110.         (setf (rref go-away rect.topleft)
  111.               (add-points (rref structure rect.topleft) #@(4 2)))
  112.         (setf (rref go-away rect.botRight)
  113.               (add-points (rref structure rect.topleft) #@(14 11))))
  114.       (cond
  115.        ((= message #$wDraw)             ; DRAW THE WINDOW MESSAGE
  116.         (if (pref theWindow WindowRecord.visible)
  117.           (let ((draw-option (#_LoWord param)));; see TN-290 
  118.             (cond 
  119.              ((= draw-option 0)
  120.               (with-port (%get-ptr window-manager-port)
  121.                 (let ((temp (new-region))
  122.                       (drag-region (new-region))
  123.                       (title-end 0))
  124.                   ;; draw the frame
  125.                   (set-rect-region drag-region structure)
  126.                   (set-rect-region temp content)
  127.                   (xor-region drag-region temp drag-region)
  128.                   (dispose-region temp)
  129.                   (#_FrameRgn drag-region)
  130.                   (inset-region drag-region 1 1)
  131.                   (#_EraseRgn drag-region)
  132.                   (dispose-region drag-region)
  133.                   ;; draw the title
  134.                   (#_TextFont #$geneva)
  135.                   (#_TextSize 9)
  136.                   (with-returned-pstrs ((title "insert-title-here"))
  137.                     (#_GetWTitle theWindow title)
  138.                     (setq title-end
  139.                           (if (pref theWindow WindowRecord.goAwayFlag)
  140.                             (+ (rref go-away Rect.right)
  141.                                (#_StringWidth title) 4)
  142.                             (+ (rref structure Rect.left)
  143.                                (#_StringWidth title) 7)))
  144.                      (if (pref theWindow WindowRecord.goAwayFlag)
  145.                        (#_MoveTo (+ (rref go-away Rect.right) 2)
  146.                         (+ (rref structure Rect.top) 10))
  147.                        (#_MoveTo (+ (rref structure Rect.left) 5)
  148.                         (+ (rref structure Rect.top) 10)))
  149.                      (#_DrawString title))
  150.                   (#_TextFont #$systemFont)
  151.                   (#_TextSize 12)
  152.                   ;; draw the highlighting
  153.                   (if (pref theWindow WindowRecord.hilited)
  154.                     (progn
  155.                       ;; draw the go-away box, if there is one
  156.                       (if (pref theWindow WindowRecord.goAwayFlag)
  157.                         (#_FrameRect go-away))
  158.                       (if (= varCode 0)
  159.                         (#_PaintRect grow))
  160.                       (#_MoveTo (+ (rref structure Rect.left) 2)
  161.                        (+ (rref structure Rect.top) 2))
  162.                       (#_LineTo (+ (rref structure Rect.left) 2)
  163.                        (- (rref structure Rect.bottom) 3))
  164.                       (#_LineTo (- (rref structure Rect.right) 3)
  165.                        (- (rref structure Rect.bottom) 3))
  166.                       (#_LineTo (- (rref structure Rect.right) 3)
  167.                        (+ (rref structure Rect.top) 2))
  168.                       (dotimes (i 5)
  169.                         (#_MoveTo title-end (+ (rref go-away Rect.top) (* i 2)))
  170.                         (#_LineTo (- (rref structure Rect.right) 3)
  171.                          (+ (rref go-away Rect.top) (* i 2)))))))))
  172.              ;; toggle the go-away box by inverting it
  173.              ((= draw-option #$wInGoAway)
  174.               (with-port (%get-ptr window-manager-port)
  175.                 (inset-rect go-away 1 1)
  176.                 (#_InvertRect go-away))))))
  177.         0)
  178.        ((= message #$wHit)              ; HIT-TEST WINDOW MESSAGE
  179.         (let ((where (make-point param)))
  180.           (cond
  181.            ((point-in-rect-p content where) #$wInContent)
  182.            ((and (= varCode 0)
  183.                  (point-in-rect-p grow where)) #$wInGrow)
  184.            ((and (pref theWindow WindowRecord.goAwayFlag)
  185.                  (point-in-rect-p go-away where)) #$wInGoAway)
  186.            ((point-in-rect-p structure where) #$wInDrag)
  187.            (t #$wNoHit))))
  188.        ((= message #$wCalcRgns)         ; CALCULATE REGIONS MESSAGE
  189.         (set-rect-region (pref theWindow windowrecord.contRgn) content)
  190.         (set-rect-region (pref theWindow windowrecord.strucRgn) structure)
  191.         0)
  192.        ((= message #$wGrow)             ; DRAW GROW IMAGE FRAME MESSAGE
  193.         (rlet ((grow-content :rect)
  194.                (grow-structure :rect))
  195.           (copy-record (%int-to-ptr param) :rect grow-content)
  196.           (copy-record grow-content :rect grow-structure)
  197.           (inset-rect grow-structure -5 -5)
  198.           (setf (rref grow-structure rect.top)
  199.                 (- (rref grow-structure rect.top) 8))
  200.           (with-port (%get-ptr window-manager-port)
  201.             (#_FrameRect grow-structure)
  202.             (inset-rect grow-content -1 -1)
  203.             (#_FrameRect grow-content)))
  204.         0)
  205.        ((= message #$wDrawGIcon)        ; DRAW GROW ICON MESSAGE
  206.         ;   normally we'd draw the grow icon here, but since it's
  207.         ; not in the content region, we draw the grow icon in the
  208.         ; #$wDraw part (see above)
  209.         0)
  210.        ((= message #$wNew)              ; INITIALIZE MESSAGE
  211.         ; initialize any structures set up specifically for this window
  212.         0)
  213.        ((= message #$wDispose)          ; DISPOSE MESSAGE
  214.         ; undo whatever you did in #$wNew...
  215.         0)
  216.        (t 0)))))
  217.  
  218.  
  219. ;; before creating any windows using the above window definition
  220. ;; procedure, we have to add a tweeked WDEF resource that points
  221. ;; to it in the current resource file.
  222. ;; WARNING:  if you don't already have the WDEF in your resource
  223. ;; file, some virus protection programs might give you some grief.
  224. ;; the thing to do if this happens is either (a) add the resource
  225. ;; to MCL yourself (read about what tweek-it does) or (b) disable
  226. ;; your virus protection init for a short while.
  227.  
  228. (tweek-it "WDEF" kMyWDEFid lisp-window-definition)
  229.  
  230.  
  231. ;; I'm defining a tweeked-window class here to set the
  232. ;; ccl::grow-icon-p slot when a growable window is created,
  233. ;; since this isn't done automatically. plus they're a descendant
  234. ;; of fred-windows so you can try 'em out.
  235.  
  236. (defclass tweeked-window (fred-window) ())
  237.  
  238. (defmethod initialize-instance ((self tweeked-window) 
  239.                                 &key (procid (* kMyWDEFid 16)))
  240.   (call-next-method)
  241.   (if (= procid (* kMyWDEFid 16))
  242.     (setf (slot-value self 'ccl::grow-icon-p) t)))
  243.  
  244.  
  245. ;; here's some example windows:
  246. #|
  247. (setq *wp-one* (make-instance 'tweeked-window 
  248.                  :procid (* kMyWDEFid 16)
  249.                  :view-position #@(116 84)
  250.                  :view-size #@(231 87)
  251.                  :window-title "A MCL2 WDEF in action!"
  252.                  :close-box-p nil))
  253.  
  254. (setq *wp-two* (make-instance 'tweeked-window 
  255.                  :procid (* kMyWDEFid 16)
  256.                  :view-position #@(168 125)
  257.                  :view-size #@(231 87)
  258.                  :window-title "A WDEF in Lisp!"))
  259.  
  260. (setq *wp-three* (make-instance 'tweeked-window 
  261.                    :procid (1+ (* kMyWDEFid 16))
  262.                    :view-position #@(207 159)
  263.                    :view-size #@(231 87)
  264.                    :window-title "MCL2 WDEF in action!"))
  265.  
  266. (ed-insert-with-undo *wp-one*
  267.                      "A growable window with no close box....")
  268. (fred-update *wp-one*)
  269. (ed-insert-with-undo *wp-two*
  270.                      "A growable window with a close box....")
  271. (fred-update *wp-two*)
  272. (ed-insert-with-undo *wp-three*
  273.                      "A statically sized window with a close box....")
  274. (fred-update *wp-three*)
  275.  
  276. |#
  277. ;; end of file tweek-it.lisp
  278.